home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
cmpnew
/
cmptest.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
8KB
|
253 lines
;;; CMPTEST Functions for compiler test.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(defun self-compile ()
(with-open-file (log "lsplog" :direction :output)
(let ((*standard-output* (make-broadcast-stream *standard-output* log)))
; (self-compile2 "cmpbind")
; (self-compile2 "cmpblock")
; (self-compile2 "cmpcall")
; (self-compile2 "cmpcatch")
(self-compile2 "cmpenv")
; (self-compile2 "cmpeval")
; (self-compile2 "cmpflet")
; (self-compile2 "cmpfun")
; (self-compile2 "cmpif")
; (self-compile2 "cmpinline")
(self-compile2 "cmplabel")
; (self-compile2 "cmplam")
; (self-compile2 "cmplet")
; (self-compile2 "cmploc")
; (self-compile2 "cmpmap")
; (self-compile2 "cmpmulti")
; (self-compile2 "cmpspecial")
; (self-compile2 "cmptag")
; (self-compile2 "cmptop")
; (self-compile2 "cmptype")
(self-compile2 "cmputil")
; (self-compile2 "cmpvar")
; (self-compile2 "cmpvs")
; (self-compile2 "cmpwt")
))
t)
(defun setup ()
; (allocate 'cons 800)
; (allocate 'string 256)
; (allocate 'structure 32)
; (allocate-relocatable-pages 128)
; (load ":udd:common:cmpnew:cmpinline.lsp")
(load ":udd:common:cmpnew:cmputil.lsp")
; (load ":udd:common:cmpnew:cmptype.lsp")
; (load ":udd:common:cmpnew:cmpbind.lsp")
; (load ":udd:common:cmpnew:cmpblock.lsp")
(load ":udd:common:cmpnew:cmpcall.lsp")
; (load ":udd:common:cmpnew:cmpcatch.lsp")
; (load ":udd:common:cmpnew:cmpenv.lsp")
; (load ":udd:common:cmpnew:cmpeval.lsp")
(load ":udd:common:cmpnew:cmpflet.lsp")
; (load ":udd:common:cmpnew:cmpfun.lsp")
; (load ":udd:common:cmpnew:cmpif.lsp")
(load ":udd:common:cmpnew:cmplabel.lsp")
; (load ":udd:common:cmpnew:cmplam.lsp")
; (load ":udd:common:cmpnew:cmplet.lsp")
(load ":udd:common:cmpnew:cmploc.lsp")
; (load ":udd:common:cmpnew:cmpmain.lsp")
; (load ":udd:common:cmpnew:cmpmap.lsp")
; (load ":udd:common:cmpnew:cmpmulti.lsp")
; (load ":udd:common:cmpnew:cmpspecial.lsp")
; (load ":udd:common:cmpnew:cmptag.lsp")
(load ":udd:common:cmpnew:cmptop.lsp")
; (load ":udd:common:cmpnew:cmpvar.lsp")
; (load ":udd:common:cmpnew:cmpvs.lsp")
; (load ":udd:common:cmpnew:cmpwt.lsp")
; (load ":udd:common:cmpnew:lfun_list")
; (load ":udd:common:cmpnew:cmpopt.lsp")
)
(defun cli () (process ":cli.pr"))
(defun load-fasl ()
(load "cmpinline")
(load "cmputil")
(load "cmpbind")
(load "cmpblock")
(load "cmpcall")
(load "cmpcatch")
(load "cmpenv")
(load "cmpeval")
(load "cmpflet")
(load "cmpfun")
(load "cmpif")
(load "cmplabel")
(load "cmplam")
(load "cmplet")
(load "cmploc")
(load "cmpmap")
(load "cmpmulti")
(load "cmpspecial")
(load "cmptag")
(load "cmptop")
(load "cmptype")
(load "cmpvar")
(load "cmpvs")
(load "cmpwt")
(load "cmpmain.lsp")
(load "lfun_list.lsp")
(load "cmpopt.lsp")
)
(setq *macroexpand-hook* 'funcall)
(defun self-compile1 (file)
(prin1 file) (terpri)
(compile-file1 file
:fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t))
(defun self-compile2 (file)
(prin1 file) (terpri)
(compile-file1 file
:fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t)
(prin1 (load file)) (terpri))
(defvar *previous-form* nil)
(defun cmp (form)
(setq *previous-form* form)
(again))
(defun again ()
(init-env)
(print *previous-form*)
(terpri)
(setq *compiler-output1* *standard-output*)
(setq *compiler-output2* *standard-output*)
(setq *compiler-output-data* *standard-output*)
(let ((prev (get-dispatch-macro-character #\# #\,)))
(set-dispatch-macro-character #\# #\,
'si:sharp-comma-reader-for-compiler)
(unwind-protect
(t1expr *previous-form*)
(set-dispatch-macro-character #\# #\, prev)))
(catch *cmperr-tag* (ctop-write "test"))
t)
;(defun make-cmpmain-for-unix ()
; (print "unixmain")
; (format t "~&The old value of *FEATURES* is ~s." *features*)
; (let ((*features* '(unix common kcl)))
; (format t "~&The new value of *FEATURES* is ~s." *features*)
; (init-env)
; (compile-file1 "cmpmain.lsp"
; :output-file "unixmain"
; :c-file t
; :h-file t
; :data-file t
; :system-p t
; ))
; (format t "~&The resumed value of *FEATURES* is ~s." *features*)
; )
(defun compiler-make-ufun ()
(make-ufun '(
"cmpbind.lsp"
"cmpblock.lsp"
"cmpcall.lsp"
"cmpcatch.lsp"
"cmpenv.lsp"
"cmpeval.lsp"
"cmpflet.lsp"
"cmpfun.lsp"
"cmpif.lsp"
"cmpinline.lsp"
"cmplabel.lsp"
"cmplam.lsp"
"cmplet.lsp"
"cmploc.lsp"
"cmpmain.lsp"
"cmpmap.lsp"
"cmpmulti.lsp"
"cmpspecial.lsp"
"cmptag.lsp"
"cmptop.lsp"
"cmptype.lsp"
"cmputil.lsp"
"cmpvar.lsp"
"cmpvs.lsp"
"cmpwt.lsp"
))
t)
(defun remrem ()
(do-symbols (x (find-package 'lisp))
(remprop x 'inline-always)
(remprop x 'inline-safe)
(remprop x 'inline-unsafe))
(do-symbols (x (find-package 'system))
(remprop x 'inline-always)
(remprop x 'inline-safe)
(remprop x 'inline-unsafe)))
(defun ckck ()
(do-symbols (x (find-package 'lisp))
(when (or (get x 'inline-always)
(get x 'inline-safe)
(get x 'inline-unsafe))
(print x)))
(do-symbols (x (find-package 'si))
(when (or (get x 'inline-always)
(get x 'inline-safe)
(get x 'inline-unsafe))
(print x))))
(defun make-cmpopt (&aux (eof (cons nil nil)))
(with-open-file (in "cmpopt.db")
(with-open-file (out "cmpopt.lsp" :direction :output)
(print '(in-package 'compiler) out)
(terpri out) (terpri out)
(do ((x (read in nil eof) (read in nil eof)))
((eq x eof))
(apply #'(lambda (property return-type side-effectp new-object-p
name arg-types body)
(when (stringp body)
(do ((i 0 (1+ i))
(l nil)
(l1 nil))
((>= i (length body))
(when l1
(setq body
(concatenate 'string
"@"
(reverse l1)
";"
body))))
(when (char= (aref body i) #\#)
(incf i)
(cond ((member (aref body i) l)
(pushnew (aref body i) l1))
(t (push (aref body i) l))))))
(print
`(push '(,arg-types ,return-type ,side-effectp
,new-object-p ,body)
(get ',name ',property))
out))
(cdr x)))
(terpri out))))